
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : doxygen.scm
;; DESCRIPTION : 'doxygen' support for C++
;; COPYRIGHT   : (C) 2007  Gregoire Lecerf
;;
;; This software falls under the GNU general public license version 3 or later.
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(texmacs-module (utils misc doxygen)
  (:use (ice-9 rdelim)))

(display "TeXmacs] Loading doxygen C++ support\n")

;; Global variables

; Directory containing the current tag file
(define current-dir "")

(define current-source-file "")
(define current-namespace "")

; This table associate an url to a complete C++ expression
(define tag->url (make-ahash-table))

; This table stores a list of valid C++ expression for a key word.
(define key->tag (make-ahash-table))

; Time stamps are stored for tag files in order to
; refresh them when needed.
(define file->stamp (make-ahash-table))

;; Parsing

(define (tagged? x l)
  ; #t iff l is a tag of type x, i.e. (x blabla)
  (and (list? l) (nnull? l) (eq? (car l) x)))

(define (parse-attributes x)
  (let ((attrs '()) ; assoc set of the attibutes to be returned
	(l (cdr x)))
    (while (nnull? l)
	   (let ((x (car l)))
	     (if (and (list? x) (= (length x) 2))
		 (set! attrs
		       (assoc-set! attrs (car x)  (cadr x)))))
	   (set! l (cdr l)))
    attrs))

(define (html->ascii s)
  ; Do a couple of string substitutions
  (let* ((x (string-replace s "&amp;" "&"))
	 (x (string-replace x "&lt;"  "<"))
	 (x (string-replace x "&gt;"  ">")))
    x))

(define (relative-path s)
  ; If s is a path to a header file blabla/include/mypackage...
  ; then return mypackage...
  (let ((i (string-search-forwards "include/" 0 s)))
    (if (>= i 0)
	(substring s (+ i 8))
	s)))

(define (cpp_basename s)
  ; If s is class name like blabla::name
  ; then return name
  (let ((i (string-contains? s "::"))
	(j (string-contains? s "<"))
	(k (string-contains? s "(")))
    (cond
     ((integer? i) (cpp_basename (substring s (+ i 2))))
     ((integer? j) (cpp_basename (substring s 0 j)))
     ((integer? k) (cpp_basename (substring s 0 k)))
     (else s))))

(define (parse-member argl)
  (let ((kind "")
	(type "")
	(name "")
	(arglist "")
	(anchorfile "")
	(anchor "")
	(l (cdr argl))
	(attrs '()))
    (while (nnull? l)
	   (let ((x (car l)))
	     (cond
	      ((string? x)) ; these are only spaces
	      ((tagged? '@ x)
	       (set! attrs (parse-attributes x))
	       (set! kind (assoc-ref attrs 'kind)))
	      ((tagged? 'type x)
	       (if (nnull? (cdr x))
		   (set! type (html->ascii (second x)))))
	      ((tagged? 'name x) (set! name (second x)))
	      ((tagged? 'arglist x)
	       (if (nnull? (cdr x))
		   (set! arglist (html->ascii (second x)))))
	      ((tagged? 'anchorfile x)
	       (set! anchorfile (second x)))
	      ((tagged? 'anchor x)
	       (set! anchor (second x)))
	      (else
	       (display "TeXmacs] doxygen warning, unknown tag type within a 'member:\n")
	       (display x)
	       (newline))))
	   (set! l (cdr l)))
    (let ((url (string-append current-dir "/" anchorfile "#" anchor)))
      (cond
       ((== kind "define")
	(let ((tag (string-append current-source-file ":" name arglist))) 
	  (ahash-set! tag->url tag url)
	  (ahash-set! key->tag name
		      (cons tag (ahash-ref* key->tag name '())))))
       ((== kind "function")
	(let ((tag (string-append type " " current-namespace name arglist)))
	  (ahash-set! tag->url tag url)
	  (ahash-set! key->tag (cpp_basename name)
		     (cons tag (ahash-ref* key->tag name '())))))
       ((or (== kind "variable")
	    (== kind "typedef")
	    (== kind "enumeration")
	    (== kind "enumvalue"))
	(let ((tag (string-append current-namespace name)))
	  (ahash-set! tag->url tag url)
	  (ahash-set! key->tag (cpp_basename name)
		     (cons tag (ahash-ref* key->tag name '())))))
       ((== kind "friend"))
       (else
	(display "TeXmacs] doxygen warning, unknown kind of 'member:\n")
	(display kind)
	(newline))))))

(define (parse-compound_struct x)
  (let ((name "")
	(path "")
	(filename "")
	(templargs "")
	(templarg "")
	(previous-namespace current-namespace)
	(l (cdr x)))
    (while (nnull? l)
	   (let ((x (car l)))
	     (cond
	      ((string? x)) ; these are only spaces
	      ((tagged? '@ x))
	      ((tagged? 'path x))
	      ((tagged? 'base x))
	      ((tagged? 'class x))
	      ((tagged? 'struct x))
	      ((tagged? 'name x)
	       (set! name (html->ascii (second x)))
	       (set! current-namespace (string-append
					current-namespace
					name "::")))
	      ((tagged? 'filename x)
	       (set! filename (second x)))
	      ((and (tagged? 'templarg x) (= (length x) 2))
	       (set! templarg (html->ascii (second x)))
	       (if (string-null? templargs)
		   (set! templargs templarg)
		   (set! templargs (string-append templargs ", " templarg))))
	      ((tagged? 'templarg x))
	      ((tagged? 'member x) (parse-member x))
	      (else
	       (display "TeXmacs] doxygen warning, unknown tag type within a 'struct 'compound:\n")
	       (display x)
	       (newline))))
	   (set! l (cdr l)))
    (if (not (string-null? templargs))
	(set! templargs (string-append "< " templargs " >")))
    (let ((tag (string-append previous-namespace name)))
      (ahash-set! tag->url tag (string-append current-dir "/" filename))
      (ahash-set! key->tag (cpp_basename name)
		 (cons tag (ahash-ref* key->tag (cpp_basename name) '()))))
    (set! current-namespace previous-namespace)))

(define (parse-compound_file x)
  (let ((name "")
	(path "")
	(filename "")
	(previous-namespace current-namespace)
	(l (cdr x)))
    (while (nnull? l)
	   (let ((x (car l)))
	     (cond
	      ((string? x)) ; these are only spaces
	      ((tagged? '@ x))
	      ((tagged? 'path x) (set! path (relative-path (second x))))
	      ((tagged? 'name x)
	       (set! name (second x))
	       (set! current-source-file name))
	      ((tagged? 'filename x)
	       (set! filename (string-append (second x) ".html")))
	      ((tagged? 'namespace x)
	       (set! current-namespace
		     (string-append previous-namespace (second x) "::")))
	      ((tagged? 'member x) (parse-member x))
	      ((tagged? 'class x))
	      ((tagged? 'docanchor x))
	      ((tagged? 'includes x))
	      (else
	       (display "TeXmacs] doxygen warning, unknown tag type within a 'file 'compound:\n")
	       (display x)
	       (newline))))
	   (set! l (cdr l)))
    (let ((tag (string-append path name)))
      (ahash-set! tag->url tag (string-append current-dir "/" filename))
      (ahash-set! key->tag name (cons tag (ahash-ref* key->tag name '()))))
    (set! current-namespace previous-namespace)))

(define (parse-compound x)
  (let ((kind "")
	(l (cdr x))
	(attrs '()))
    (while (and (nnull? l) (== kind ""))
	   (let ((x (car l)))
	      (if (tagged? '@ x)
		  (begin
		    (set! attrs (parse-attributes x))
		    (set! kind (assoc-ref attrs 'kind))))
	   (set! l (cdr l))))
    (cond
     ((== kind "file") (parse-compound_file x))
     ((== kind "namespace"))
     ((or (== kind "class")
	  (== kind "struct"))
      (parse-compound_struct x))
     (else
      (display "TeXmacs] doxygen warning, unknown kind of 'compound:\n")
      (display kind)
      (newline)))))

(define (parse-tagfile x)
  (let ((l (cdr x)))
    (while (nnull? l)
	   (let ((x (car l)))
	     (cond
	      ((string? x)) ; these are only spaces
	      ((tagged? 'compound x) (parse-compound x))
	      (else
	       (display "TeXmacs] doxygen warning, unknown tag within a 'tagfile:")
	       (display x)
	       (newline))))
	   (set! l (cdr l)))))

(define (parse-main s)
  ; s is a string that stores the content of a tag file
  (let ((l (parse-xml s)))
    (while (nnull? l)
	   (let ((x (car l)))
	     (cond
	      ((string? x)) ; these are essentially spaces
	      ((equal? x '*TOP*))
	      ((tagged? '*PI* x))
	      ((tagged? 'tagfile x) (parse-tagfile x))
	      (else
	       (display "TeXmacs] doxygen warning, unknown tag:")
	       (display x)
	       (newline))))
	   (set! l (cdr l)))))

(define (load-tag-file relative_filename)
  (let ((filename (string-append
		 (dirname (url->string (get-name-buffer)))
		 "/" relative_filename)))
    (if (access? filename R_OK)
	(let ((nst (stat:mtime (stat filename)))
	      (ost (ahash-ref* file->stamp filename '())))
	  (if (not (equal? nst ost))
	      (let* ((p (open-input-file filename))
		     (s (read-delimited "" p)))
		(close-input-port p)
		(ahash-set! file->stamp filename nst)
		(set! current-dir (dirname relative_filename))
		(parse-main s)
		)))
	(texmacs-error "Doxygen: file not found" filename))))

; TeXmacs exports

(tm-define (doxygen-load l)
	   (:secure #t)
	   (:synopsis "Load Doxygen tag file.")
 	   (load-tag-file (tree-as-string l))
	   "")

(tm-define (doxygen-ref x)
	   (:secure #t)
	   (:synopsis "Get the url for the given Doxygen tag.")
	   (let* ((xs (tree-as-string x))
		  (y (ahash-ref* tag->url xs "")))
	     (if (string-null? y)
		 (let ((proposal (ahash-ref* key->tag xs '())))
		   (cond
		    ((null? proposal) (texmacs-error "doxygen"
		     (string-append "Invalid Doxygen tag: " xs)))
		    ((= 1 (length proposal))
		     (tree-set! x (first proposal))
		     (ahash-ref tag->url (first proposal)))
		    (else
		     (dialogue
		      (set! y (dialogue-ask
			       (cons "Pick up a correct tag:"
				     (cons "Question" proposal))))
		      (tree-set! x y)
		      (ahash-ref tag->url y)))))
		 y)))

